home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / ms_acces / mdbguru / dict.bas < prev    next >
Encoding:
BASIC Source File  |  1994-09-24  |  13.3 KB  |  397 lines
  1. Option Explicit
  2.  
  3. ' for the ini file stuff
  4. Declare Function GetPrivateProfileInt% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%, ByVal lpFileName$)
  5. Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFileName$)
  6.  
  7.  
  8. ' status function
  9. Const DICT_STATUS_FATAL = 1
  10. Const DICT_STATUS_MESSAGE = 2
  11. Const DICT_STATUS_PROGRESS = 3
  12.  
  13. ' status function can return one of these values
  14. Const DICT_STATUS_RETURN_NONE = 0
  15.  
  16.  
  17.  
  18. '
  19. ' Data Access constants
  20. '
  21.  
  22. ' Option argument values (CreateDynaset, etc)
  23. Global Const DB_DENYWRITE = &H1
  24. Global Const DB_DENYREAD = &H2
  25. Global Const DB_READONLY = &H4
  26. Global Const DB_APPENDONLY = &H8
  27. Global Const DB_INCONSISTENT = &H10
  28. Global Const DB_CONSISTENT = &H20
  29. Global Const DB_SQLPASSTHROUGH = &H40
  30.  
  31. ' SetDataAccessOption
  32. Global Const DB_OPTIONINIPATH = 1
  33.  
  34. ' Field Attributes
  35. Global Const DB_FIXEDFIELD = &H1
  36. Global Const DB_VARIABLEFIELD = &H2
  37. Global Const DB_AUTOINCRFIELD = &H10
  38. Global Const DB_UPDATABLEFIELD = &H20
  39.  
  40. ' Field Data Types
  41. Global Const DB_BOOLEAN = 1
  42. Global Const DB_BYTE = 2
  43. Global Const DB_INTEGER = 3
  44. Global Const DB_LONG = 4
  45. Global Const DB_CURRENCY = 5
  46. Global Const DB_SINGLE = 6
  47. Global Const DB_DOUBLE = 7
  48. Global Const DB_DATE = 8
  49. Global Const DB_TEXT = 10
  50. Global Const DB_LONGBINARY = 11
  51. Global Const DB_MEMO = 12
  52.  
  53. ' TableDef Attributes
  54. Global Const DB_ATTACHEXCLUSIVE = &H10000
  55. Global Const DB_ATTACHSAVEPWD = &H20000
  56. Global Const DB_SYSTEMOBJECT = &H80000002
  57. Global Const DB_ATTACHEDTABLE = &H40000000
  58. Global Const DB_ATTACHEDODBC = &H20000000
  59.  
  60. ' ListTables TableType
  61. Global Const DB_TABLE = 1
  62. Global Const DB_QUERYDEF = 5
  63.  
  64. ' ListTables Attributes (for QueryDefs)
  65. Global Const DB_QACTION = &HF0
  66. Global Const DB_QCROSSTAB = &H10
  67. Global Const DB_QDELETE = &H20
  68. Global Const DB_QUPDATE = &H30
  69. Global Const DB_QAPPEND = &H40
  70. Global Const DB_QMAKETABLE = &H50
  71.  
  72. ' ListIndexes IndexAttributes values
  73. Global Const DB_UNIQUE = 1
  74. Global Const DB_PRIMARY = 2
  75. Global Const DB_PROHIBITNULL = 4
  76. Global Const DB_IGNORENULL = 8
  77. ' ListIndexes FieldAttributes value
  78. Global Const DB_DESCENDING = 1  'For each field in Index
  79.  
  80. ' CreateDatabase and CompactDatabase Language constants
  81. Global Const DB_LANG_GENERAL = ";LANGID=0x0809;CP=1252;COUNTRY=0"
  82. Global Const DB_LANG_SPANISH = ";LANGID=0x040A;CP=1252;COUNTRY=0"
  83. Global Const DB_LANG_DUTCH = ";LANGID=0x0413;CP=1252;COUNTRY=0"
  84. Global Const DB_LANG_SWEDFIN = ";LANGID=0x040C;CP=1252;COUNTRY=0"   'VB3 and Access 1.1 Databases
  85. Global Const DB_LANG_NORWDAN = ";LANGID=0x0414;CP=1252;COUNTRY=0"   'VB3 and Access 1.1 Databases
  86. Global Const DB_LANG_ICELANDIC = ";LANGID=0x040F;CP=1252;COUNTRY=0" 'VB3 and Access 1.1 Databases
  87. Global Const DB_LANG_NORDIC = ";LANGID=0x041D;CP=1252;COUNTRY=0"    'Access 1.0 Databases only
  88.  
  89. ' CreateDatabase and CompactDatabase options
  90. Global Const DB_VERSION10 = 1        ' Microsoft Access Version 1.0
  91. Global Const DB_ENCRYPT = 2          ' Make database encrypted.
  92. Global Const DB_DECRYPT = 4          ' Decrypt database while compacting.
  93.  
  94. 'Collating order values
  95. Global Const DB_SORTGENERAL = 256    ' Sort by EFGPI rules (English, French, German,Portuguese, Italian)
  96. Global Const DB_SORTSPANISH = 258    ' Sort by Spanish rules
  97. Global Const DB_SORTDUTCH = 259      ' Sort by Dutch rules
  98. Global Const DB_SORTSWEDFIN = 260    ' Sort by Swedish, Finnish rules
  99. Global Const DB_SORTNORWDAN = 261    ' Sort by Norwegian, Danish rules
  100. Global Const DB_SORTICELANDIC = 262  ' Sort by Icelandic rules
  101. Global Const DB_SORTPDXINTL = 4096   ' Sort by Paradox international rules
  102. Global Const DB_SORTPDXSWE = 4097    ' Sort by Paradox Swedish, Finnish rules
  103. Global Const DB_SORTPDXNOR = 4098    ' Sort by Paradox Norwegian, Danish rules
  104. Global Const DB_SORTUNDEFINED = -1   ' Sort rules are undefined or unknown
  105.  
  106. Function dictCreate (ByVal cIniFile As String, ByVal cNewDBName As String) As Integer
  107.     Dim i               As Integer
  108.     Dim j               As Integer
  109.     Dim cDBName         As String
  110.     Dim cLang           As String
  111.     Dim ret             As Integer
  112.     Dim db              As database
  113.     Dim nTables         As Integer
  114.     Dim cQDefName       As String
  115.     Dim nQDefs          As Integer
  116.     Dim nFields         As Integer
  117.     Dim nIndexes        As Integer
  118.     Dim lAttached       As Integer
  119.     Dim cConnect        As String
  120.     Dim cSource         As String
  121.     Dim cBuffer         As String
  122.     Dim cIdxFields      As String
  123.     
  124.     Dim tbd()           As New tabledef
  125.     Dim idx()           As New index
  126.     Dim fld()           As New field
  127.     Dim qd()            As querydef
  128.  
  129.     Dim cAttr           As String
  130.     Dim nAttr           As Long
  131.     Dim cType           As String
  132.     Dim cTableName      As String
  133.     Dim cFieldName      As String
  134.     Dim cIdxName        As String
  135.     Dim lPrimary        As Integer
  136.     Dim lUnique         As Integer
  137.     Dim nSize           As Integer
  138.     Dim nType           As Integer
  139.     Dim cSQL            As String
  140.     
  141.  
  142.     dictCreate = False
  143.     If cNewDBName = "" Then
  144.     cDBName = Space(80)
  145.     
  146.     ret = GetPrivateProfileString("Database", "Name", "", cDBName, 80, cIniFile)
  147.     cDBName = Trim(cDBName)
  148.     If cDBName = "" Then
  149.         ret = dictStatus(DICT_STATUS_FATAL, "Invalid Database name or INI File invalid format!", 0, 0)
  150.         Exit Function
  151.     End If
  152.     Else
  153.     cDBName = cNewDBName
  154.     End If
  155.     
  156.     cLang = Space(20)
  157.     ret = GetPrivateProfileString("Database", "Language", "", cLang, 20, cIniFile)
  158.     cLang = Trim(cLang)
  159.     If cLang = "" Then
  160.     ret = dictStatus(DICT_STATUS_FATAL, "Invalid Database name or INI File invalid format!", 0, 0)
  161.     Exit Function
  162.     End If
  163.  
  164.     On Error Resume Next
  165.     Kill cDBName
  166.     On Error GoTo cantDoIt
  167.     
  168.     ret = dictStatus(DICT_STATUS_MESSAGE, "Creating database", 0, 0)
  169.     Select Case cLang
  170.     Case "DB_LANG_GENERAL"
  171.         Set db = CreateDatabase(cDBName, DB_LANG_GENERAL)
  172.     Case "DB_LANG_SPANISH"
  173.         Set db = CreateDatabase(cDBName, DB_LANG_SPANISH)
  174.     Case "DB_LANG_DUTCH"
  175.         Set db = CreateDatabase(cDBName, DB_LANG_DUTCH)
  176.     Case "DB_LANG_SWEDFIN"
  177.         Set db = CreateDatabase(cDBName, DB_LANG_SWEDFIN)
  178.     Case "DB_LANG_NORWDAN"
  179.         Set db = CreateDatabase(cDBName, DB_LANG_NORWDAN)
  180.     Case "DB_LANG_ICELANDIC"
  181.         Set db = CreateDatabase(cDBName, DB_LANG_ICELANDIC)
  182.     Case "DB_LANG_NORDIC"
  183.         Set db = CreateDatabase(cDBName, DB_LANG_NORDIC)
  184.     Case Else
  185.         Set db = CreateDatabase(cDBName, DB_LANG_GENERAL)
  186.     End Select
  187.     
  188.  
  189.     nTables = GetPrivateProfileInt("Tables", "Count", 0, cIniFile)
  190.     ret = dictStatus(DICT_STATUS_PROGRESS, "Creating tables", 0, nTables)
  191.     For i = 1 To nTables
  192.     cTableName = Space(80)
  193.     ret = GetPrivateProfileString("Tables", "Table" + LTrim(Str(i - 1)), "", cTableName, 80, cIniFile)
  194.     
  195.     ' strip the table attributes off the name
  196.     cTableName = Trim(cTableName)
  197.     cAttr = Mid(cTableName, InStr(cTableName + ",", ",") - 1)
  198.     cTableName = Mid(cTableName, 1, InStr(cTableName + ",", ",") - 1)
  199.     If cTableName = "" Then
  200.         ret = dictStatus(DICT_STATUS_FATAL, "Error in INI File creating table " + LTrim(Str(j - 1)), 0, 0)
  201.         Exit Function
  202.     End If
  203.  
  204.     ret = dictStatus(DICT_STATUS_PROGRESS, "Creating table " + cTableName, i, nTables)
  205.     
  206.     nAttr = 0
  207.     lAttached = False
  208.     If InStr(cAttr, "DB_ATTACHEXCLUSIVE") Then
  209.         nAttr = nAttr + DB_ATTACHEXCLUSIVE
  210.         lAttached = True
  211.     End If
  212.     If InStr(cAttr, "DB_ATTACHSAVEPWD") Then
  213.         nAttr = nAttr + DB_ATTACHSAVEPWD
  214.         lAttached = True
  215.     End If
  216.     If InStr(cAttr, "DB_SYSTEMOBJECT") Then
  217.         nAttr = nAttr + DB_SYSTEMOBJECT
  218.     End If
  219.     If InStr(cAttr, "DB_ATTACHEDTABLE") Then
  220.         nAttr = nAttr + DB_ATTACHEDTABLE
  221.         lAttached = True
  222.     End If
  223.     If InStr(cAttr, "DB_ATTACHEDODBC") Then
  224.         nAttr = nAttr + DB_ATTACHEDODBC
  225.         lAttached = True
  226.     End If
  227.  
  228.     ReDim tbd(1) As New tabledef
  229.     tbd(0).Name = cTableName
  230.     If nAttr Then
  231.         tbd(0).Attributes = nAttr
  232.         If lAttached Then
  233.         cConnect = Space(80)
  234.         ret = GetPrivateProfileString(cTableName, "Connect", "", cConnect, 80, cIniFile)
  235.         cConnect = Left(cConnect, ret)
  236.         If cConnect = "" Then
  237.             ret = dictStatus(DICT_STATUS_FATAL, "Error in INI file creating connected table " + cTableName, 0, 0)
  238.             Exit Function
  239.         End If
  240.         cSource = Space(80)
  241.         ret = GetPrivateProfileString(cTableName, "SourceTable", "", cSource, 80, cIniFile)
  242.         cSource = Left(cSource, ret)
  243.         If cSource = "" Then
  244.             ret = dictStatus(DICT_STATUS_FATAL, "Error in INI file creating connected table " + cTableName, 0, 0)
  245.             Exit Function
  246.         End If
  247.         tbd(0).Connect = cConnect
  248.         tbd(0).SourceTableName = cSource
  249.         End If
  250.     End If
  251.  
  252.  
  253.     nFields = GetPrivateProfileInt(cTableName, "FieldCount", 0, cIniFile)
  254.     For j = 1 To nFields
  255.  
  256.         cBuffer = Space(128)
  257.         ret = GetPrivateProfileString(cTableName, "Field" + LTrim(Str(j - 1)), "", cBuffer, 128, cIniFile)
  258.         If Trim(cBuffer) = "" Then
  259.         ret = dictStatus(DICT_STATUS_FATAL, "Error in INI file creating fields for table " + cTableName, 0, 0)
  260.         Exit Function
  261.         End If
  262.         cFieldName = Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1)
  263.         cBuffer = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  264.         cType = Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1)
  265.         cBuffer = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  266.         nSize = Val(Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1))
  267.         cBuffer = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  268.         cAttr = Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1)
  269.         
  270.         Select Case cType
  271.         Case "DB_LONG"
  272.             nType = DB_LONG
  273.         Case "DB_INTEGER"
  274.             nType = DB_INTEGER
  275.         Case "DB_TEXT"
  276.             nType = DB_TEXT
  277.         Case "DB_BOOLEAN"
  278.             nType = DB_BOOLEAN
  279.         Case "DB_SINGLE"
  280.             nType = DB_SINGLE
  281.         Case "DB_DOUBLE"
  282.             nType = DB_DOUBLE
  283.         Case "DB_MEMO"
  284.             nType = DB_MEMO
  285.         Case "DB_BYTE"
  286.             nType = DB_BYTE
  287.         Case "DB_DATE"
  288.             nType = DB_DATE
  289.         Case "DB_LONGBINARY"
  290.             nType = DB_LONGBINARY
  291.         Case "DB_CURRENCY"
  292.             nType = DB_CURRENCY
  293.         Case Else
  294.             ret = dictStatus(DICT_STATUS_FATAL, "Error in INI file creating fields for table " + cTableName, 0, 0)
  295.             Exit Function
  296.         End Select
  297.  
  298.         nAttr = 0
  299.         If InStr(cAttr, "DB_FIXEDFIELD") Then nAttr = nAttr + DB_FIXEDFIELD
  300.         If InStr(cAttr, "DB_AUTOINCRFIELD") Then nAttr = nAttr + DB_AUTOINCRFIELD
  301.         If InStr(cAttr, "DB_UPDATABLEFIELD") Then nAttr = nAttr + DB_UPDATABLEFIELD
  302.  
  303.         ReDim fld(0) As New field
  304.         fld(0).Name = cFieldName
  305.         fld(0).Type = nType
  306.         fld(0).Size = nSize
  307.         fld(0).Attributes = nAttr
  308.         tbd(0).Fields.Append fld(0)
  309.     Next j
  310.  
  311.     nIndexes = GetPrivateProfileInt(cTableName, "IndexCount", 0, cIniFile)
  312.     For j = 1 To nIndexes
  313.         ReDim idx(1) As New index
  314.         cBuffer = Space(128)
  315.         ret = GetPrivateProfileString(cTableName, "Index" + LTrim(Str(j - 1)), "", cBuffer, 128, cIniFile)
  316.         cIdxName = Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1)
  317.         cBuffer = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  318.         cIdxFields = Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1)
  319.         cBuffer = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  320.         lPrimary = Val(cBuffer)
  321.         cBuffer = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  322.         lUnique = Val(cBuffer)
  323.         
  324.         idx(0).Name = cIdxName
  325.         idx(0).Fields = cIdxFields
  326.         idx(0).Unique = lUnique
  327.         idx(0).Primary = lPrimary
  328.         tbd(0).Indexes.Append idx(0)
  329.     Next j
  330.     
  331.     db.TableDefs.Append tbd(0)
  332.  
  333.     Next i
  334.     ret = dictStatus(DICT_STATUS_PROGRESS, "", -1, 0)
  335.  
  336.     nQDefs = GetPrivateProfileInt("QueryDefinitions", "Count", 0, cIniFile)
  337.     ret = dictStatus(DICT_STATUS_PROGRESS, "Creating query definitions", 0, nQDefs)
  338.     For i = 1 To nQDefs
  339.     cBuffer = Space(1024)
  340.     ret = GetPrivateProfileString("QueryDefinitions", "QueryDef" + LTrim(Str(i - 1)), "", cBuffer, 1024, cIniFile)
  341.     cBuffer = Left(cBuffer, ret)
  342.     If cBuffer = "" Then
  343.         ret = dictStatus(DICT_STATUS_FATAL, "Error in INI file creating query definition " + LTrim(Str(i - 1)), 0, 0)
  344.         Exit Function
  345.     End If
  346.     cQDefName = Mid(cBuffer, 1, InStr(cBuffer + ",", ",") - 1)
  347.     cSQL = Mid(cBuffer, InStr(cBuffer + ",", ",") + 1)
  348.  
  349.     ret = dictStatus(DICT_STATUS_PROGRESS, "", i, nQDefs)
  350.     ReDim qd(0) As querydef
  351.     Set qd(0) = db.CreateQueryDef(cQDefName, cSQL)
  352.     qd(0).Close
  353.  
  354.     Next i
  355.     ret = dictStatus(DICT_STATUS_PROGRESS, "", -1, 0)
  356.     
  357.     db.Close
  358.     ret = dictStatus(DICT_STATUS_MESSAGE, "Database creation complete", 0, 0)
  359.     dictCreate = True
  360.     Exit Function
  361.  
  362. cantDoIt:
  363.     ret = dictStatus(DICT_STATUS_FATAL, Error$, 0, 0)
  364.     Exit Function
  365. End Function
  366.  
  367. Function dictStatus (nType As Integer, cMsg As String, nItem As Integer, nItems As Integer) As Integer
  368.     dictStatus = DICT_STATUS_RETURN_NONE
  369.     Select Case nType
  370.     Case DICT_STATUS_FATAL
  371.         fTestDict.Label1.Caption = cMsg
  372.         fTestDict.hsProgress.Visible = False
  373.         MsgBox cMsg, MB_OK, "Fatal Error!"
  374.  
  375.     Case DICT_STATUS_MESSAGE
  376.         fTestDict.Label1.Caption = cMsg
  377.         fTestDict.Label1.Refresh
  378.  
  379.     Case DICT_STATUS_PROGRESS
  380.         If nItem = 0 Then
  381.         fTestDict.hsProgress.Visible = True
  382.         fTestDict.hsProgress.Min = 1
  383.         fTestDict.hsProgress.Max = nItems
  384.         fTestDict.hsProgress.Value = 1
  385.         
  386.         ElseIf nItem = -1 Then
  387.         fTestDict.hsProgress.Visible = False
  388.         Else
  389.         fTestDict.hsProgress.Value = nItem
  390.         End If
  391.         fTestDict.Label1.Caption = cMsg
  392.         fTestDict.Label1.Refresh
  393.  
  394.     End Select
  395. End Function
  396.  
  397.